Wstępna analiza surowych danych pokazała bardzo dużą ilość brakujących danych (powyżej 80%). Większość wierszy zawierała wyniki co najwyżej kilku z kilkudziesięcie (powyżej 70) atrybutów. Podczas czyszczenia danych usunięto kilka atrybutów nieposiadających żadnych wartości. W innych kolumnach częściowo uzupełniono brakujące wartości wykorzystując interpolację lub stałą wartość. W zbiorze wynikowym pozostawiono ok 8% wartości nieokreślonych. W wyczyszczonym zbiorze danych znajduje się 5606 wierszy, które zawierają wyniki badań 360 pacjentów. Wśród pacjentów było 212 mężczyzn oraz 149 kobiet. Przeżyło 166 pacjentów (30.9% chorych kobiet i 56.6% chorych mężczyzn). Dane zbierane były w okresie 10.01.2020 - 04.03.2020. Atrybuty opisują wyniki badań krwi pacjentów. Między większością atrybutów zachodzi korelacja (negatywna lub pozytywna). Udało się znaleźć model klasyfikatora, który dla podanych danych testowych osiąga potrafi przewidzieć, czy pacjent przeżyje z dokładnością wynoszącą 95%.
library(xlsx)
library(DT)
library(knitr)
library(dplyr)
library(tidyr)
library(janitor)
library(imputeTS)
library(lares)
library(plotly)
library(caret)
library(qgraph)
library(ggforce)
raw_data <- read.xlsx(filename, 1)
raw_data <- as_tibble(raw_data)
dim(raw_data)
## [1] 6120 81
Pierwsze 30 wierszy ze zbioru:
*** Podstawowe statystyki dla całego zbioru:## Dane bedace wartoscami brakujacymi (NA): 88 %
## Wartosc minimalna: -1
## Wartosc maksymalna: 50000
## Liczba pacjentów: 375
## Okres zbierania danych: 2020-01-10 15:52:19 - 2020-03-04 16:21:51
Podstawowe statystyki dla poszczególnych atrybutów:
Wstępne czyszczenie danych:
#replace -1 with NA
raw_data[raw_data==-1]<-NA
#filling PATIENT_ID
id_filled <- raw_data %>% fill(PATIENT_ID)
#remove rows where all variables are empty
vars <- colnames(id_filled)[-(1:7)]
no_empty_rows<- id_filled[rowSums(is.na(id_filled[vars])) != length(vars), ]
no_empty_cols <- no_empty_rows[colSums(!is.na(no_empty_rows)) > 0]
#renaming columns
colnames_cleaned <- no_empty_cols %>% clean_names()
colnames_cleaned$outcome=factor(colnames_cleaned$outcome, labels = make.names(c("death", "release")))
colnames_cleaned$gender=factor(colnames_cleaned$gender, labels = make.names(c("M", "F")))
Eliminacja brakujących wartości na poziomie pacjenta obejmowała:
Jeżeli żadne z powyższych rozwiązań nie było możliwe, wartości NA zostawiono.
clean_NA<-function(column){
not_NA_count<-sum(!is.na(column))
if (not_NA_count>=2){ #interpolate
column <- na_interpolation(column, option = "linear")
column
}
else if (not_NA_count==1){ #constant value
val <- first(na.omit(column))
column[is.na(column)] <- val
column
}#default: leave NA values
column
}
#for each patient:
# for each column:
# clean_NA
cleaned<- colnames_cleaned%>% group_by(patient_id) %>% mutate_each(list(clean_NA))
#extract columns with attributes only
attributes<-cleaned[-(1:7)]
Podsumowanie zbioru:
| Parametr | Wartosc |
|---|---|
| Liczba pacjentów | 360 |
| Liczba pomiarów | 5606 |
| Srednia liczba pomiarów na pacjenta | 16 |
| Liczba kolumn | 80 |
| Liczba zmiennych | 73 |
| Procent brakujacych wartosci | 6 |
Wykresy prezentujące podział danych ze względu na płeć i rezultat:
Wykres obrazujący czasy przyjęcia i wypisania lub śmierci z wyróżnieniem płci:
***Tabela pokazująca 30 pierwszych rekordów po wyczyszczeniu danych:
Podsumowanie każdego z atrybutów:
***Histogramy przedstawiajace rozkład atrybutów:
Poniższy graf przedstawia korelację pomiędzy parami atrybutów. Grubość lini łączącej dwa atrybuty jest zależna od współczynnika korelacji, natomiast kolor oznacza korelację dodatnią (kolor zielony) lub ujemną (kolor czerwony)
Wykres przedstawiający 20 par atrybutów z największą korelacją:
Poniższy wykres przedstawia wartości atrybutów hemoglobin (poziom hemoglobiny we krwi) oraz glucose (poziom glukozy we krwi) dla poszczególnych dni pobytu pacjenta w szpitalu. Celem wykresu jest próba pokazania zmiany tych atrybutów w czasie hospitalizacji pacjentów.
Przygotowanie danych do klasyfikacji:
Budowa klasyfikatora:
tune_grid <- expand.grid(mtry = 10:30)
gridCtrl <- trainControl(
method = "repeatedcv",
summaryFunction = twoClassSummary,
classProbs = TRUE,
number = 2,
repeats = 10)
fitTune <- train(outcome ~ .,
data = training,
method = "rf",
metric = "ROC",
preProc = c("center", "scale"),
trControl = gridCtrl,
tuneGrid = tune_grid,
ntree = 30)
prediction <- predict(fitTune,
newdata = testing)
Podsumowanie rezultatu:
ggplot(fitTune) + theme_bw()
confusionMatrix(data = prediction,
testing$outcome)
## Confusion Matrix and Statistics
##
## Reference
## Prediction death release
## death 47 3
## release 1 37
##
## Accuracy : 0.9545
## 95% CI : (0.8877, 0.9875)
## No Information Rate : 0.5455
## P-Value [Acc > NIR] : <0.0000000000000002
##
## Kappa : 0.9079
##
## Mcnemar's Test P-Value : 0.6171
##
## Sensitivity : 0.9792
## Specificity : 0.9250
## Pos Pred Value : 0.9400
## Neg Pred Value : 0.9737
## Prevalence : 0.5455
## Detection Rate : 0.5341
## Detection Prevalence : 0.5682
## Balanced Accuracy : 0.9521
##
## 'Positive' Class : death
##